\ ------------------  CLONECFA ... the big one! -------------------- /
\
\   When an unresolved reference is target compiled, two behaviors are
\ possible:
\
\ 1. Leave 3 words (48 bits) so that  a LONG ABS may be used.  This
\    usually will only be filled with a relative BSR and a NOOP, however.
\    A program will have to significantly exceed 128k, actually, before
\    a LONG ABSOLUTE JSR is required.  Better to try...
\
\ 2. Only leave 32-bit cells on the HIGH probability that all the code
\    will fit under 128k (Target Compiled!).
\
\   The following variable 'IfLeaveLong' allows the selection of either.
\ If set TRUE, it will leave 48-bit holes.  Do NOT change this while
\ Target Compiling is in progress!  Leaving this variable FALSE is heartily
\ reccomended; if your code is huge, wait till the error message, then set it
\ TRUE and start over.

\ 00001 18-jan-91 mdh  fixed problem with ALITERALs  ( added swap )
\ 00002 PLB 1/29/91 Remove duplicate TARGETABS +STACK in ResolveAll
\ 00003 PLB 2/5/91 Add IF.FORGOTTEN INITCLONE
\ 00004 PLB/MDH 2/6/91 Add calls to SizeDiff? in CloneUnresolved
\ 00005 mdh 4/24/91 new defer

only forth definitions

decimal  ANew TASK-Clone.f

variable IfLeaveLong   \ if non-zero, leave 3 words (see above text)...
variable InitialImageSize  ( starting size to avoid expansion )
variable IfLongBranch

also TGT definitions


\ flags and general variables...

variable PktBase       \ address of the 'attribute' packet for this CFA...
variable TargetBase    \ the address of this word in the target...
variable HiBranch      \ an RTS without a branch around means done...
variable CurrentDiff   \ current difference in pfa size
variable ThisOp
variable SPECIAL_ID
variable TargetDataStart

1 array testarray

\ stacks ...

  0 DynamicStack UnResolved  \ to 'remember' calls to the non-existant ones...
  0 DynamicStack TargetABS   \ for tracking required Long Relocations...
128 DynamicStack DiffSizes   \ addrs of size diffs and the diffs...
  8 DynamicStack BranchAdrs  \ local stack pointing to the Branch opcodes...
  0 DynamicStack OpenCells   \ will be resolved to an address...
128 DynamicStack ?DOIndexes
  8 DynamicStack ValueRefs
  8 DynamicStack CFATables
  8 DynamicStack TGTCFATables
  8 DynamicStack :ClassCFAS
  8 DynamicStack DictPCRels
  8 DynamicStack ImagePCRels
  8 DynamicStack FromCFAs

also forth definitions


: InitClone
  UnResolvedVAR FreeStack
  TargetABSVAR  FreeStack
  DiffSizesVAR  FreeStack
  BranchAdrsVAR FreeStack
  OpenCellsVAR  FreeStack
  ?DOIndexesVAR FreeStack
  ValueRefsVAR  FreeStack
  CFATables     FreeStack
  TGTCFATables  FreeStack
  :ClassCFAS    FreeStack
  DictPCRels    FreeStack
  ImagePCRels   FreeStack
  FromCFAs      FreeStack
  InitClone
;

if.forgotten initclone \ 00003

previous definitions

.need K
: K 1024 * ;
.then



USE_NEW_COLON on

\ 10 constant OVERLAY_CALL_SIZE
   4 constant OVERLAY_CALL_SIZE

: CALCCALL  ( calledOpAdr callingOpAdr -- opcode data #bytes , if #bytes<8)
            (                     ELSE    opcode w@aN-2 .. w@a0 N*2 )
  \
  CloneOverlay @    InMaster @ 0=  AND
  IF
\ x ) dbgon >newline ." CALCCALL passed an overlay function: " .s >newline dbgoff
     \ need new 'call' mechanism...
[ 0 .if ]
     \
     \ move.l  #CalledAdr,a0
     \ jsr     0(a5,a0.l)     a5 set by StartOverlay (in startjforth.asm)
     \
     >r        >r
     $ 8800    $ 4eb5
     r@        r> 16 -shift
     $ 207c
     OVERLAY_CALL_SIZE        rdrop
[ .else ]
     \
     \ bsr  calledaddr
     \
     2dup 2+ -  [ decimal ]  dup -32769 >  over 32768 < and
     IF
        -rot 2drop   $ 6100  swap  4
     ELSE
        cr ." Overlay too large.  CLONE Aborted." quit
     THEN
[ .then ]
  ELSE
     \ is it within relative-distance range?
     \
     InMaster @
     IF
        0 0   \ can't allow if in master
     ELSE
        2dup 2+ -  [ decimal ]  dup -32769 >  over 32768 < and
     THEN
     ( -- cldop clngop rel-displacement flag )
     IF
        -rot 2drop   $ 6100  swap  4
     ELSE
        drop
        over  [ 32 k ] literal <
        IF
           \
           \ Origin relative...
           \
           drop $ 4eac swap 4
        ELSE
           \
           \ if 32k - 96k, use +64k relative...
           \
           over  [ 96 k ] literal <
           IF
              drop  [ 64 k ] literal -  $ 4eab swap   4
           ELSE
              \
              \ Push CallingOpAdr+2 on TargetABS stack for relocation.
              2+ TargetABS +stack  $ 4eb9 swap 6
           THEN
        THEN
     THEN
  THEN 
;

USE_NEW_COLON off



\ ----------- AllotData ------------------------------------------
\

: AllotDATA  ( areastart -- )
  NextLFA drop
  Mindiff @  4 max            \ TargetAllot
  cell /mod swap IF 1+ THEN   ( -- #cells )
  StartArea @ swap 0
  DO
     dup @ Target, cell+
  LOOP
  drop
;


: RegisterDiff  ( #bytes -- )  currentdiff +!
\    TargetHere 2+  TargetBase @ -  DiffSizes  +stack
       ThisOp @ 2+     CFABase @ -  DiffSizes  +stack
     currentdiff @  DiffSizes  +stack
;


USE_NEW_COLON on

: SizeDiff?  ( opadr #bytes -- )
  0 >r   swap w@ swap  ( opcode #bytes )  over BranchOp?
  IF
     ( -- opc #bytes )  over  ShortBRA? 0= 0=  IfLongBranch @ and
     IF
        rdrop 2 >r
     THEN
  ELSE
     ( apcode #bytes )  dup     4  3 pick  $ 4eb9 =
     IF
        2+
     THEN
     ( -- opcode #bytes #bytes #indict )
     rdrop   - >r
\
[ 0 .if ]
     over $ 4eb9 =    over 4 =  and
     IF
        \
        \ original call was Absolute (6 bytes), targeted will be 4...
        \
        rdrop -2 >r
     ELSE
        over $ 4eb9 = 0=  over 6 =  and
        IF
           \
           \ original was relative (4 bytes), targeted will be 6...
           \
           rdrop 2 >r
        THEN
     THEN
[ .then ]
\
  THEN
  r> ?dup
  IF
     ( -- opc #bytes amt-diff )  RegisterDiff
  THEN
  2drop
;

: Special?  ( cfa -- ??_ID , return ID code if not a colon def )
  \
  \ Check if the SFA has a special_ID marked in the SFA...
  \
  dup PacketFor ..@ ref_IsPFA dup
  IF
      drop dup cell- @ $ f,0000 and
  THEN
  swap drop
;

: LITERALADDR?  ( cfa -- flag , true if literal references to a data area )
  Special? dup VARIABLE_ID = swap USER_ID = or
;

: CloneOverlayReference  ( w@aN-2 .. w@a0 N*2 -- )
  0 DO
     TargetW,  2
  +LOOP
;

: WriteOverlayReference  ( w@aN-2 .. w@a0 N*2 tgtaddr -- )
\ x ) dbgon >newline ." Entering WriteOverlayReference: " .s >newline dbgoff
  TargetHERE >r   \ save current tgt-here
  TargetImageBase freebytea !   \ install tgtaddr
  CloneOverlayReference
  r> TargetImageBase freebytea !
;

: CloneExisting  ( opadr tgtcalled calledcfa -- opadr )
  2 pick >r
  LiteralAddr?
  IF
     InMaster @   CloneOverlay @ 0=   or
     IF
        $ 2d07 targetw, \ put in move.l tos,-(dsp)
        2 RegisterDiff
        $ 2e3c          \ opcode for move.l  # ...
        swap   6        ( -- opadr opcode data #bytes )
     ELSE
     	\ move.l  d7,(-a6)
     	\ move.l  #value,tos
     	\ add.l   a5,tos
     	\ sub.l   org,tos
     	\
     	>r
     	$ 9e8c
     	$ de8d
     	r@
     	r> 16 -shift
     	$ 2e3c
     	$ 2d07
     	12
     THEN
  ELSE
     TargetHERE      ( -- opadr tgtcalled tgtcalling )
     CalcCall        ( -- opadr opcode data #bytes )
  THEN
  r> over            ( -- opadr opcode data #bytes opadr #bytes )
  SizeDiff?          ( -- opadr opcode data #bytes )
\
  dup 7 <
  IF
     rot TargetW,       ( -- opadr data #bytes )
     4 =
     IF
        TargetW,
     ELSE
        Target,
     THEN
  ELSE
     CloneOverlayReference
  THEN
;


: CloneUnresolved  ( opadr calleda -- opadr )
  \
  \ 1. Store called native PFA in opcode 'hole'
  \ 2. Push Target Address of 'hole' on the 'UnResolved' stack.
  \
  dup LiteralAddr?  dup>r
  IF
     $ 2d07 targetw,   2  RegisterDiff
  THEN
  TargetHERE  UnResolved   +stack
  ( -- opadr calleda )  Target,
  ( -- opadr )  CloneOverlay @
  IF
     r@   \ LITERAL?
     IF
        $ 4e71 TargetW,
        dup 6 SizeDiff?  \ 00004
     ELSE
\ x ) dbgon >newline ." CLONEing unresolved at " TargetHERE .hex cr dbgoff
        [ OVERLAY_CALL_SIZE cell- ] literal  TargetAllot
        dup OVERLAY_CALL_SIZE SizeDiff?
     THEN
  ELSE
     IfLeaveLong @  r@ or
     IF
        $ 4e71 TargetW,
        dup 6 SizeDiff?  \ 00004
     ELSE
        \ calc change in size for 4 byte BSR or JSR
        ( -- opadr )  dup 4 SizeDiff? \ 00004
   \ x ) dbgon >newline ." CloneUnresolved, after SizeDiff 4: " .s >newline dbgoff
     THEN
   THEN
   rdrop
;


: ResolveCells
  OpenCellsBase freecell  ( -- #unreslvds )  0
  DO
     \
     \ Get the address containing the native PFA...
     \
     OpenCellsBase i cells + @
     \
     \ Get the NATIVE pfa we need to locate in the target...
     \
     dup Target@  ( -- tgtadr nativepfa )
     \
     \ Find its TargetAdr
     \
     abs PacketFor  dup  ..@ ref_Resolved 0=
     IF
        ( -- tgtadr pkt )
        >newline ." UnResolved reference to RESIDENT address " over target@
        base @ >r hex 0 .r ." , from cell " over . r> base !  cr
     ELSE
        ( -- tgtadr pkt )
        dup ..@ ref_TgtAdr  2 pick Target!
     THEN
     2drop
  LOOP
  OpenCellsBase FreeByteA off
;


: ResolveODE  ( -- )
  :ClassCFASBase freecell 0
  DO
     i :ClassCFASBase stack@
     ( -- :classCFA ) dup PacketFor ..@ ref_TGTAdr >r
     >LastIvar @  ?dup
     IF
        dup do-does-size -   ( -- ivardata ivarcfa )
        PacketFor ..@ ref_TgtAdr do-does-size + r@ >LastIvar  Target!
        ( -- ivardata )
        BEGIN
           do-does-size -  ( ivcfa )
           dup PacketFor ..@ ref_TgtAdr >r  ( -r- tgtivcfa )  
           dup >IvarClass @ do-does-size - PacketFor
           ..@ ref_TgtAdr do-does-size +  ( ivcfa tgtivclass )
           r@ >IvarClass Target!          ( ivcfa )
           >PrevIvar @ ?dup
        WHILE
           dup  do-does-size - PacketFor
           ..@ ref_TgtAdr do-does-size +  ( previvar tgtPrevIvar )
           r> >PrevIvar Target!           ( previvar )
        REPEAT
        rdrop
     THEN
     rdrop
  LOOP
;

: ResolvePCRels ( -- )
  DictPCRelsBase freecell 0
  DO
     ( -- )
     i DictPCRelsBase stack@  ( -- &dictop )
     PCRel>Dest  ( -- ref-dict-adr )
\ >newline hex .s
     Dict>TGT  ( -- ref-tgt-adr )
     i ImagePCRelsBase stack@  ( -- rta &tgtopcode )  dup>r
     Dest>PCRel dup $ ffff,8000 <  over $ 7fff > or
     IF
        >newline ." Destination PC-relative address too far away: "
        i DictPCRelsBase stack@ .hex  drop
     ELSE
        r@ 2+ TargetW!
     THEN
     rdrop
  LOOP
;

: NoForwardRefs  ( -- , aborts )   \ NEEDS TO HANDLE FORWARD REFS IN OVRLYS
   >newline
   cr ." This version of CLONE cannot resolve forward references"
   cr ." when creating overlays.  This can be caused by DEFERed"
   cr ." words pointing to later definitions.  It is suggested that"
   cr ." you set these to NOOP at compile time, and run-time initialize"
   cr ." the DEFERed words to the later definitions." cr
   cr ." CLONE aborted (INITCLONE before CLONEing again)"  quit
;

: ResolveAll  ( -- )
  ResolveCells
  UnResolvedBase freecell  ( -- #unreslvds )  0
  DO
     \
     \ Get the address containing the native PFA...
     \
     UnResolvedBase i cells + @
     \
     \ Get the NATIVE pfa we need to locate in the target...
     \
     dup Target@  ( -- tgtopadr nativepfa )  dup>r  ( -r- nativecfa )
     \
     \ Find its TargetAdr
     \
     abs PacketFor  dup>r  ..@ ref_Resolved 0=  ( -r- ntvcfa pkt )
     IF
        ( -- tgtopadr )  ( -r- nativepfa??neg pkt )
        >newline ." UnResolved reference to RESIDENT address " dup target@
        base @ swap hex 0 .r ." , from " over . base !  cr
     ELSE
        ( -- tgtopadr )  ( -r- cfa packet )
        r@ ..@ ref_TgtAdr   1 rpick 0<
        IF
           true  ( address literals are saved NEGATEd )
        ELSE
           1 rpick LiteralAddr?
        THEN
        ( -- tgtopadr tgtadr flag )
        IF
           $ 2e3c 2 pick targetW!
           over 2+  Target!
        ELSE
           over
           ( -- calling calledtgtadr callingadr )  dup>r CalcCall
           dup 7 <   CloneOverlay @ 0= or
           IF
              ( -- calling opcode data #bytes )   6 =
              IF
                 IfLeaveLong @ 0=
                 IF
                    2drop >newline
                    ." LONG RELOCATIONS are necessary; the variable IFLEAVELONG" cr
      ( 00001 )     ."      must be set TRUE; then INITCLONE and try again." cr
                    quit
                 ELSE
                    ( -- calling opcode called )    swap 2 pick TargetW!
                    \ already stacked!  ( -- calling called )
                    \ removed!          over 2+ dup TargetABS +stack
                    ( -- calling called )      over 2+  \ 00002
                    ( -- calling called calling+2 )    Target!
                 THEN
              ELSE
                 ( -- opadr opcode displacement )  swap 2 pick TargetW!
                 over 2+ TargetW!  ( -- opadr )
              THEN
           ELSE
               ( -- calling wdata@adrN-2 .. wdata@adr0 N*2 )
               ( -r- ntvcfa pkt callingop )
[ 1 .if ]
( x ) dbgon >newline ." write fwd ref: " cr r@ base @ >r hex .s r> base ! drop cr dbgoff
              r@  WriteOverlayReference
[ .else ]
              NoForwardRefs
[ .then ]
           THEN
           rdrop
        THEN
     THEN
     drop  2 xrdrop
  LOOP
  UnResolvedBase FreeByteA off
  ResolveODE
  ResolvePCRels
;


: CloneCall  ( opadr calledadr -- opadr )
  \
  \ This address calls 'nother...   ( -- opadr calledadr )
  \
  dup PacketFor dup ..@ ref_Resolved
  ( -- opadr calledadr calledpkt  flag )
  IF
     \
     \ the word exists in the target...
     \
     ..@ ref_tgtadr  ( -- opadr calleda tgta )
     swap            ( -- opadr tgtcalled calledcfa )
     CloneExisting
  ELSE
     \
     \ the word has NOT been built in the Target yet.
     \
     ( -- opadr calleda calledpkt )
\ x ) dbgon >newline ." CloneCall, not resolved: " .s >newline dbgoff
     drop CloneUnresolved
  THEN
  \
  \ Is this call followed by a string?
  \
  ( -- opadr )  dup +NextOp drop $op @
  IF
     >r
     r@ dup w@ opsize dup >r +   ( -- $startaddr )  ( -r- opadr oplen )
     r> r@ +NextOp swap -        ( -- $start $len )
     2/ 0
     DO
        dup w@  ( dup hex . ) TargetW,  2+
     LOOP
     drop r>
  THEN
;

: CheckOverlayRelative  ( -- )
  CloneOverlay @  InMaster @ 0=  and
  IF
     \ make relative
     $ de8d Targetw,		\ add.l  a5,tos
     $ 9e8c Targetw,		\ sub.l  org,tos
     4 RegisterDiff
  THEN
;

: CloneALit  ( opadr referenced-adr -- opadr )  Substitute?
  dup do-does-size - IsValuePFA?  ( CloneOverlay @ 0= and )
  IF
     $ 2e3c Targetw,  TargetHERE  ValueRefs +stack   Target,
     CheckOverlayRelative
     ( targetdataAddr = dictdataaddr  ValueRefsStack = TargetDataAddr )
  ELSE
     dup ValidPFA?
     IF
        \
        \ the address IS a cfa
        \
        dup PacketFor dup ..@ ref_Resolved   ( -- opadr ref-adr packet flag )
        IF
           $ 2e3c TargetW,
           ..@ ref_TgtAdr  Target,   CheckOverlayRelative
           drop
        ELSE
[ 0 .if
           \
           \ not built in target yet...
           \
           CloneOverlay @
           IF
              NoForwardRefs  \ aborts
           THEN
[ .then ]
           drop
           TargetHERE UnResolved +stack              \ save tHERE as unrslvd
           negate  ( negative=flag for ALit) Target, \ install dict adr in img
           $ 4e71 Targetw,
        THEN
     ELSE
        \
        \ assume it's referencing some CREATE DOES> child...
        \
        ( -- opadr refadr )           dup >CFA
        ( -- opadr refadr it's-cfa )  dup cell- @  $ f,0000 and
        CASE
           VARIABLE_ID of
              dup [ PktBase ' PktBase - ] literal +
              ( -- opadr refadr cfa cfa+data ) 2 pick
              swap ( 00001 )      -  endof
           CREATE_ID   of
              2dup -           endof
\          VALUE_ID   of
           >newline ." ALITERAL points to ????, can't CLONE opcode at "
           ThisOp @ hex u. quit
        ENDCASE
        ( -- opadr refadr cfa diff-from-tgt-adr ) swap
        PacketFor    ( -- opadr refadr diff pkt )  ..@ ref_TgtAdr +
        $ 2e3c TargetW,  Target,   CheckOverlayRelative  drop
     THEN
  THEN
;

0 .IF
: CloneBranch  ( opadr destadr -- opadr )
  dup hibranch @ max hibranch !
  over w@ ( -- opadr destadr opcode )
  dup ShortBRA?
  IF
     2 pick 4 SizeDiff?
  THEN
  targetHERE  BranchAdrs   +stack
  dup $ 5fff >
  IF
     $ ff00 and
  THEN Targetw,
  \
  \ after the opcode, save the dict-cfa-relative address referenced...
  \
  CFABase @ -  Targetw,
;


: FixBranch  ( TGTopadr -- )
  \
  \ get the dict-rel-addr being called...
  \
  2+ dup Targetw@  ( -- tgtdispadr reldest )
  DiffSizesBase     ( -- tgtdispadr reldest base )
  dup freebyte +
  BEGIN
     [ 2 cells ] literal -  dup @  2 pick <=
  UNTIL
  cell+ @  ( -- disptgtadr reldest sizediff )  + targetbase @ +
  over - swap targetw!
;
.ELSE
: CloneBranch  ( opadr destadr -- opadr )
  2 x>r
  \           1      0
  \  ( -r- destadr opadr )
  \
  1 rpick  hibranch @ ( hex .s ?pause decimal )  max hibranch !
  r@ w@ dup >r   ShortBRA? >r
  \
  \           3      2      1      0
  \  ( -r- destadr opadr opcode ifshort )
  \
  IfLongBranch @
  IF
     r@
     IF
        2 rpick 4 SizeDiff?
     THEN
  THEN
  \
  targetHERE  BranchAdrs   +stack
  1 rpick dup  $ 5fff >  IfLongBranch @ and
  IF
     $ ff00 and
  THEN
  Targetw,
  \
  \ after the opcode, save the dict-cfa-relative address referenced...
  \
  3 rpick  CFABase @ -  FromCFAs  +stack
  r@  IfLongBranch @ 0=  and  0=
  IF
     0 Targetw,
  THEN
  2 xrdrop r> rdrop

;

: FixBranch  ( TGTopadr branch# -- )
  2 x>r
  \           1        0
  \  ( -r- branch# TGTopadr )  
  \
  \ get the dict-rel-addr being called...
  \
  1 rpick FromCFAsBase stack@  ( -- reldest )
  DiffSizesBase     ( -- reldest base )
  dup freebyte +
  BEGIN
     [ 2 cells ] literal -  dup @  2 pick <=
  UNTIL
  cell+ @  ( -- reldest sizediff )  + targetbase @ +
  ( -- tgtaddr )  r@ 2+ -  >r
  \
  \           2        1          0
  \  ( -r- branch# TGTopadr displacement)  
  \
  1 rpick Targetw@ ShortBRA?
  IF
     r@ 127 >   r@ -128 <  OR
     IF
\ x ) dbgon >newline r@ dup . .hex 1 rpick dup . .hex 2 rpick dup . .hex cr dbgoff
        >newline
        ." Too far for SHORT BRANCH...aborting CLONE operation." cr
        ." To successfully CLONE this program..." cr
        ." 1. Enter:   INITCLONE  IFLONGBRANCH ON  <return>" cr
        ." 2. Restart CLONE as before" quit
     ELSE
        1 rpick targetw@  $ ff00 and
        r@ $ 0ff and  or  1 rpick targetw!
     THEN
  ELSE
     r@  1 rpick 2+  targetw!
  THEN
  3 xrdrop
;

.THEN

: Set?DO   ( dict-ix-addr -- )  dup @  over 8 + +  ( -- ixadr dict-dest )
  CFABase @ -   ( -- ixadr dict-cfarel-dest )
  targetHERE cell-  dup ?DOIndexes +stack    Target!  drop
;

: Fix?DO  ( ixTGTadr -- )  dup Target@  ( -- ixadr dict-rel-addr )
  DiffSizesBase     ( -- tgtixadr reldest base )
  dup freebyte +
  BEGIN
     [ 2 cells ] literal -  dup @  2 pick <=
  UNTIL
  cell+ @  ( -- tgtixadr reldest sizediff )  + targetbase @ +
  over 8 + - swap target!
;


: FixValues  ( -- , references registered on ValueRefs stack )
  ValueRefsBase dup freecell 0
  DO
     i over stack@    ( -- base &tgtlit )
     dup Target@      ( -- base &tgtlit &dictdata )
     dup do-does-size - PacketFor dup ..@ ref_resolved 0=
     IF
        ( -- base &tgtlit &dictdata pkt )
        TargetHERE over ..! ref_TgtAdr
        true over ..! ref_resolved
        over @ Target,
     THEN
     ( -- base &tgtlit &dictdata pkt )  swap drop
     ..@ ref_TgtAdr swap Target!  ( -- base )
  LOOP freebytea off
;


: IfCall   ( opadr flag -- opadr flag' )
  dup 0=
  IF
      drop dup calls?  dup
      IF
\ x ) dbgon >newline ." IfCall. calls? returned true: " .s >newline dbgoff
          drop ( opadr calledadr )  dup ' ((?DO)) =
          IF
             ( -- opadr called )  over cell-  Set?DO
          ELSE
             Substitute?
          THEN
          CloneCall true
      THEN
  THEN
;


: IfBranch   ( opadr flag -- opadr flag' )
  dup 0=
  IF
      drop dup Branches?  dup
      IF
          drop CloneBranch true
      THEN
  THEN
;


: IfALit   ( opadr flag -- opadr flag' )
  dup 0=
  IF
      drop dup ALit?  dup
      IF
          drop CloneALit  true
      THEN
  THEN
;


: IfInline   ( opadr flag -- opadr flag' , last check! )
  dup 0=
  IF
     drop
     dup dup w@ dup $ 4e71 =
     IF
        2drop true      \ do not include 'nop's
        -2 RegisterDiff
     ELSE
        opsize  dup TargetAllot  ( -- opadr opadr size )
        TargetHere over -  TargetImageBase + swap move
        \
        \ Last instruction?
        \
        dup w@ $ 4e75 =  over hibranch @ >=   and 0=
     THEN
  THEN
  ( -- opadr flag , flag=false if end of this pfa )
;


: IfLibOpen?  ( opadr flag -- opadr' flag' )
  dup 0=
  IF
     >r ( -- opadr )   dup CallingLibOpen?
     IF
        16 +   -20 RegisterDiff    16 ThisOp +!
        rdrop  true >r
     THEN
     r>
  THEN
;

: IfPCRel  ( opadr flag -- opadr' flag' )
  dup 0=
  IF
     drop  dup w@ dup PCRel?  ( -- opadr opcode flag )
     over 1 and 0= and   \ can't calc xx(pc,??)
\ >newline .s ?pause
     IF
        over DictPCRels +stack
        TargetHERE ImagePCRels +stack
        TargetW,   0 TargetW,
        true
     ELSE
        drop false
     THEN
  THEN
;

: CloneOpcode   ( opadr -- opadr flag , true=more to do )
  dup thisOp !  false
  IfCall        ( -- opadr flag , true if processed )
  IfBranch      ( -- opadr flag )
  IfALit        ( -- opadr flag )
  IfLibOpen?    ( -- opadr flag )
  IfPCRel       ( -- opadr flag )
  IfInLine      ( -- opadr flag )
;

.need CFATABLE>
defer CFATABLE>
.then

: CloneIV  ( objbase class-cfa -- )
  dup >LastIvar @   ( -- objbase classCFA lastivar )
  BEGIN
     ?dup
  WHILE
     ( objbase classCFA lastivar )              dup @ 3 pick +
     ( objbase classCFA lastivar nextobjbase )  over do-does-size -
     ( objbase classCFA lastivar nextobjbase instobjcfa )
     >IvarClass @ do-does-size -   recurse
     do-does-size - >PrevIvar @
  REPEAT
  ( objbase class-cfa -- )
  >CFATable
  dup CFATables stackfind   ( -- objbase &table ix flag )
  IF
     cells TGTCFATables     @ ( fix by Phil )   + @ >r
  ELSE
     2dup CFATables stackinsert   ( -- objbase &table ix )
     TargetHERE dup >r
     swap TGTCFATables stackinsert  ( -- objbase &table )
     dup >#methods 0
     DO
        dup @ Substitute?
        PacketFor ..@ Ref_TgtAdr Target,  cell+
     LOOP
  THEN
  drop  ( -- objbase )  CFABase @ -  TargetBase @ +  r> swap Target!
;

: CloneHighLevel  ( -- )
  CFABase @      ( -- pfa )
  BEGIN
     \
     \ piece up the code, opcode at a time...
     \
\ x ) dbgon >newline ." New Opcode =============================" cr .s
\ x )     ?pause >newline dup .hex space dbgoff
     ( -- opadr )  CloneOpcode  ( -- opadr flag )
  WHILE
     dup +NextOp
\ x ) dbgon dup ."  next Opcode is + " .hex cr dbgoff
     +
  REPEAT
  drop
\ x ) dbgon >newline ." Fixing branches" cr .s cr dbgoff
  BranchAdrsBase dup freecell 0
  DO
     dup @ i FixBranch cell+
  LOOP
  drop  BranchAdrsBase Freebytea off   FromCFAsBase Freebytea off
\ x ) dbgon >newline ." Fixing ?DOs" cr dbgoff
  ?DOIndexesBase dup freecell 0
  DO
     dup @ Fix?DO cell+
  LOOP
  drop  ?DOIndexesBase Freebytea off
  FixValues
[ 0 .if ]
  CFABase @ dup
  Special?  dup CREATE_ID = swap GLOBDEF_ID = or
  swap ' sample-defer = or
[ .else ]
  CFABase @   Special?  dup  CREATE_ID =
[ .then ]
  IF
\ x ) dbgon >newline ." Found to be CREATE_DOES" cr dbgoff
     drop
     \
     \ calc beginning of data area...
     \
     do-does-size  TargetHERE TargetBase @ - - TargetALLOT
     \
     \ calc length of data area...
     \
     TargetHERE TargetDataStart !
     CFABase @   do-does-size +  AllotData
     \
     \ Check if it is a CLASS definition...
     \
     CFABase @ cell- @ CLASS_BIT and
     IF
        \ get the addr of the CFAs table...
        \
        CFABase @ do-does-size + dup @  ( -- objbase CFATable )
        CFATable>  CloneIV     ( -- )
     ELSE
        \ Check if it is a :CLASS definition...
        \
        CFABase @ cell- @ :CLASS_BIT and
        IF
           \ get the addr of the CFAs table...
           \
           CFABase @ dup dup :ClassCFAS StackLocate :ClassCFAS StackInsert
           >CFATable  dup CFATables stackfind  ( -- tbl ix flag )
           drop   2dup CFATables stackinsert   ( -- &table ix )
           TargetBase @ >CFATable  dup >r
           swap TGTCFATables stackinsert  ( -- &table )
           dup >#methods   r> swap 0
           DO
              ( -- &table &TGTtable )  over @ substitute?
              ( -- &table &TGTtable rescalledadr )
              dup PacketFor dup ..@ ref_Resolved
              IF
                 ( tbl tgttbl called pkt )
                 ..@ Ref_TgtAdr  swap drop  over Target!
              ELSE
                 drop
                 over dup OpenCells +stack   Target!
              THEN
              cell+ swap cell+ swap
           LOOP
           2drop
        THEN
     THEN
  ELSE
     \ is it adefered word?
     GLOBDEF_ID =
     IF
\ x ) dbgon >newline ." Found to be a DEFERed word" cr dbgoff
        TargetHERE TargetDataStart !
        \
        \ CFABase @   defer-size +  AllotData
        cell TargetAllot
        \
        \
        CloneOverlay @
        IF
           $ d800  TargetDataStart @ cell- TargetW!
        THEN
     THEN
  THEN
;


: CloneVARIABLE  ( -- )
  TargetHERE TargetDataStart !
  CFABase @  [ clicommand  ' clicommand - ] literal +  AllotData
;


: CloneUSER  ( -- )
  TargetHERE TargetDataStart !
  CFABase @execute @ Target,
;


: SetDefered  ( -- )
  CFABase @  >is @
  Substitute?  ( -- calledadr )
  dup PacketFor dup ..@ ref_Resolved  ( -- called pkt flag )
  IF
     ..@ Ref_TgtAdr  TargetDataStart @  Target!  drop
  ELSE
[ 0 .if ]
     CloneOverlay @
     IF
        NoForwardRefs
     THEN
[ .then ]
     drop
     TargetDataStart @ dup OpenCells +stack   Target!
  THEN
;


: CloneGLOBDEF  ( -- )
  CloneHighLevel  SetDefered
;

0 .IF
: CloneUSERDEF  ( -- )  CFABase @ >r
  ' SAMPLE-DEFER CFABase !
  IfCreateRefs on
  CloneHighLevel
  r>  CFABase !    SetDefered
  IfCreateRefs off
  ' SAMPLE-DEFER  References  StackFind
  IF
     dup cells RefPacketsBase + @ freeblock
     dup References StackRemove
     dup RefPackets StackRemove
  THEN
  drop
;
.ELSE
: CloneUSERDEF  ( -- )  CloneGLOBDEF  ;
.THEN

: CloneSpecial  ( ??_ID -- )
  CASE
     VARIABLE_ID of CloneVARIABLE       endof
     USER_ID     of CloneUSER           endof
     CREATE_ID   of CloneHighLevel      endof
     USERDEF_ID  of CloneUSERDEF        endof
     GLOBDEF_ID  of CloneGLOBDEF        endof
\    VALUE_ID    of CloneHighLevel      endof
       >newline ." Undefined 'DATA'_ID:" dup .hex
       ."   Cloning:"  CFABase @ .hex
  ENDCASE
;


: CloneReference  ( cfa -- )
  dup IsValuePFA? 0=
  IF
     \
     \ Initializations...
     \
     dup PacketFor PktBase !   CFABase ! 
     DiffSizesBase FreeByteA off \ init the sizediffs stacks...
     0  DiffSizes  +stack
     0  DiffSizes  +stack
     CurrentDiff off             \ no difference at start...
     TargetHERE TargetBase !     \ save the start tgt adr...
     HiBranch off                \ no branches yet!
     \
     \ not a normal colon def?
     \
     CFABase @ Special? -dup
     IF
        CloneSpecial
     ELSE
        CloneHighLevel
     THEN
     PktBase @ >r
     TargetBase @  r@  ..! ref_TgtAdr
     true          r>  ..! ref_Resolved
  ELSE
     drop
  THEN
;

: CLONE.SETUP.TARGET  ( size -- , preallocate target to save RAM )
    InitialSize @
    swap InitialSize !
    TargetImage  ( allocate data )
    0= abort" Couldn't Allocate InitialImageSize Target Area!"
    InitialSize !
;

: (FreeOverlay)  ( cfa -- , depends on CLONE putting variable right before )
\ >newline cr ." checking overlay variable..." cr
  cell- dup @ ?dup
  IF
\ >newline cr ." freeing overlay" cr
     cell-  FreeBlock   dup off
  THEN
  drop
;

: CLONECFA  ( cfa -- )
\ x ) dbgon >newline ." Entering CLONECFA..." cr .s >newline dbgoff
  InitialImageSize @ ?dup
  IF  clone.setup.target
  THEN
  \
  CFABase off
  ' noop dup is UserCleanUp   is ErrorCleanup
  \
  \ Make sure 'StartJForth' is first code word assembled...
  \
  CloneOverlay @
  IF
     ' StartOverlay
  ELSE
     ' StartJForth
  THEN
  dup>r  references StackFind swap drop 0=
  IF
\ x ) dbgon >newline ." Before tracing start word..." cr .s >newline dbgoff
     r@ TracePFA
\     CloneOverlay @
\     IF
\        0 Target,
\     THEN
\ x ) dbgon >newline ." Before building start word..." cr .s >newline dbgoff
     r@ CloneReference
\ x ) dbgon >newline ." Before CLONEing start word..." cr .s >newline dbgoff
     r@ myself
\ x ) dbgon >newline ." After CLONEing start word..." cr .s >newline dbgoff
     r@ PacketFor   1 swap ..! ref_#Times
  THEN
  rdrop
  \
  \ ( -- cfa )  Check if this word must be redefined...
  \
  Substitute?
  \
  \ ( -- cfa )  get all called definitions...
  \
\ x ) dbgon >newline ." Before tracing main word..." cr .s cr cr cr dbgoff
  TracePFA    ( -- )
\ x ) dbgon >newline ." After tracing main word..." cr .s cr dbgoff
  \
  \ Replace @execute for DEFER-EXECUTE...
  \
[ 0 .if ]
  ' defer-execute references StackFind  ( -- index flag )  swap drop
  IF
     ' sample-defer  TracePFA
     ' defer-execute references StackFind  ( -- index flag )  drop
     dup cells RefPacketsBase + @    ( -- defix pkt )
     over  References  StackRemove
     swap  RefPackets  StackRemove   ( -- pkt )
     dup ..@ ref_#Times swap freeblock
     ' @execute PacketFor dup ..@ ref_#Times   ( -- #times1 pkt #times2 )
     rot + swap ..! ref_#Times
  THEN
  ' SAMPLE-DEFER  References  StackFind
  IF
     dup cells RefPacketsBase + @ freeblock
     dup References StackRemove
     dup RefPackets StackRemove
  THEN
  drop
[ .THEN ]
  IfCreateRefs off   
  \
  \ Build from lowest cfa to highest...
  \
  References @ freebyte  ( -- #references*4 )  0
  DO
     RefPackets @ i + @  ( -- addr-of-pkt )
     ..@ ref_resolved 0=
     IF
\ x ) dbgon ." status..." cr cr cr dbgoff
        Status?
        References @ i + @
        \
        \ ( -- cfa )  this word needs built in the target.
        \
        CloneReference
     THEN
     cell
  +LOOP
  \
  \ Now take care of the kernal words that forward referenced...
  \
  ResolveAll
\ x ) dbgon >newline ." Entering CLONECFA..." cr .s >newline dbgoff
;


\ ---------------------- overlay stuff

getmodule includes

: GetFileSize  { $name | bytes fib flock -- bytes , 0=error }
  0 -> bytes
  $name access_read $lock() ?dup
  IF
     -> flock   MEMF_PUBLIC sizeof() FileInfoBlock allocblock ?dup
     IF
        -> fib   flock fib Examine()
        IF
           fib ..@ fib_Size -> bytes
        THEN
        fib freeblock
     THEN
     flock Unlock()
  THEN
  bytes
;

asm CallOverlay  ( code-start -- )
    move.l  tos,a0
    move.l  (dsp)+,tos
    jsr     0(org,a0.l)
    forth{ ] both [  }
end-code

variable OVERLAYERROR

: LoadOverlay   { $file | fsize mem file -- addr-mem / 0 }
  0 -> mem
  $file GetFileSize dup -> fsize
  IF
     $file old $fopen dup -> file
     IF
        MEMF_CLEAR fsize allocblock dup -> mem
        IF
           file  mem   fsize   fread  fsize -
           IF
              >newline ." Error reading Overlay file" cr
              file fclose  mem freeblock  0 -> mem
              OverLayError on
              quit
           ELSE
              cell +-> mem
           THEN
        ELSE
           >newline ." No memory for Overlay file" cr quit
        THEN
        file fclose
     ELSE
        >newline ." Can't open Overlay file" cr quit
     THEN
  THEN
  mem
;

: DoOverlay  { $filename var -- }
  OverLayError off
  var @ ?dup 0=
  IF
     $filename  LoadOverlay dup
     IF
        dup var !
        \ compile as a CALL...
        [ max-inline @  6 max-inline ! ]
        CallOverlay
        [ max-inline ! ]
     THEN
  ELSE
     \ compile INLINE...
     [ max-inline @  128 max-inline ! ]
     CallOverLay
     [ max-inline ! ]
  THEN
;


USE_NEW_COLON off


also Forth Definitions

: MakeOverlay  { | old>in thevarcfa -- , <wordname> }
  only redefs definitions
  >in @ -> old>in
  bl word find nip 0=   \ not already redefed?
  IF
     old>in >in !   definitions
     " OVR" count here $append   skip-word? on  [compile] variable
     latest name> -> thevarcfa
     \
     [compile] :   old>in >in !
     COMPILE ($")  bl $,
     thevarcfa cfa,   compile DoOverLay   [compile] ;
  THEN
  only forth definitions
  OverlaysDefined on
;


: CLONE.FWARNING ( -- , warn if files open )
    fcloseatbye @ memcells? 0>
    fblk @ 0= AND
    IF  >newline ." WARNING - Files Open during Clone!" cr
        ."   Any files used by a Cloned program must be opened" cr
        ."   by that program when run." cr
    THEN
;

: CLONE  ( <name> -- , create royalty free image )
  >newline
  clone.fwarning
  MaxImageSize @
  IF
     ." NOTE: the VARIABLE 'MaxImageSize' is no longer used by CLONE."
     cr
  THEN
  [compile] '  cr   dup CloneInputCFA !
  " 1m" CSIType
  ."   CLONE (version 1.5 Beta)  by Mike Haas, 06-May-92"
  " 0m" CSIType  cr  InitStatus
  OverlaysDefined @
  IF
     ' (FreeOverlay)
  ELSE
     ' drop
  THEN
  is FreeOverlay
  \
  CloneCFA   ' drop is FreeOverlay
  \
  .status   cr cr   ;

previous definitions

: (TrapPacket)   ( cfa refix -- )  base @ >r   hex
  >newline cr   ." REFERENCE ERROR:  cloning "
  CFABase @  1 .r   ." , the opcode at "
  ThisOp  @  1 .r   cr
  ." is trying to create a reference to "  swap u.
  cr TargetHERE  ." TargetHERE = " u.
  r> base !
  quit
;

' (TrapPacket) is TrapPacket

only forth definitions
also TGT
